home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / clue.lha / clue / clos-kludge / standard.l < prev   
Text File  |  1989-07-12  |  2KB  |  71 lines
  1. ;;; -*- Mode:Common-Lisp; Package:CLUEI; Syntax:COMMON-LISP; Base:10; Lowercase:T -*-
  2.  
  3. ;;;
  4. ;;;             TEXAS INSTRUMENTS INCORPORATED
  5. ;;;                  P.O. BOX 2909
  6. ;;;                   AUSTIN, TEXAS 78769
  7. ;;;
  8. ;;; Copyright (C) 1988 Texas Instruments Incorporated.
  9. ;;;
  10. ;;; Permission is granted to any individual or institution to use, copy, modify,
  11. ;;; and distribute this software, provided that this complete copyright and
  12. ;;; permission notice is maintained, intact, in all copies and supporting
  13. ;;; documentation.
  14. ;;;
  15. ;;; Texas Instruments Incorporated provides this software "as is" without
  16. ;;; express or implied warranty.
  17. ;;;
  18.  
  19. (in-package 'cluei :use '(lisp xlib))
  20.  
  21. ;;;
  22. ;;; Define the standard class
  23. ;;;
  24. ;;;  This is a seperate file, because the CLOS file must be loaded in order to
  25. ;;;  compile this one.
  26. ;;;
  27.  
  28. (eval-when (compile load eval)
  29. (setf (get 'standard-class *class-property*)
  30.       (internal-initialize-standard-class
  31.     :name 'standard-class
  32.     :slots '(name superclass-names slots variables prefix allocator default-initargs documentation metaclass)
  33.     :prefix "STANDARD-CLASS-"
  34.     :allocator 'internal-initialize-standard-class
  35.     :documentation "The standard CLOS class"))
  36. ) ;; end eval-when
  37.  
  38. ;; ****** KLUDGE to get around the lack of :around methods *******
  39. (defmethod initialize-instance-after ((instance t) &rest args)
  40.   ;; Dummy function
  41.   (ignore instance args))
  42.  
  43. (defmethod initialize-instance ((class standard-class) &key name superclass-names slots variables
  44.                 prefix allocator default-initargs documentation metaclass &allow-other-keys)
  45.   (macrolet ((init (slot &optional (value slot))
  46.            `(when ,slot (setf (slot-value (the standard-class class) ',slot) ,value))))
  47.     (init name)
  48.     (init superclass-names)
  49.     (init slots)
  50.     (init variables)
  51.     (init prefix)
  52.     (init allocator)
  53.     (init default-initargs)
  54.     (init documentation (car documentation))
  55.     (init metaclass (car metaclass))))
  56.  
  57. (defmethod default-initargs ((class standard-class) initargs)
  58.   initargs)
  59.  
  60.  
  61. ;;; Printing routines.
  62.  
  63. #-lispm
  64. (defmethod print-object ((instance t) stream)
  65.   (format stream "#<~a>" (type-of instance)))
  66.  
  67. #+lispm
  68. (defmethod print-object ((instance t) stream)
  69.   (si:printing-random-object (instance stream :typep)))
  70.  
  71.